home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Mosmlcgi.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  7.8 KB  |  235 lines  |  [TEXT/R*ch]
  1. (*
  2.  
  3.  Mosmlcgi.sml
  4.  
  5.  (c) Jonas Barklund, Computing Science Dept., Uppsala University, 1996.
  6.  
  7.  Support for form-based file upload via multipart/form-data,
  8.  by Peter Sestoft (sestoft@dina.kvl.dk) December 1996.
  9.  
  10.  Anyone is granted the right to copy and/or use this code, provided
  11.  that this note is retained, also in modified versions.  The code is
  12.  provided as is with no guarantee about any functionality.  I take no
  13.  responsibility for its proper function.
  14.  
  15. *)
  16.  
  17. val cgi_server_software = Process.getEnv("SERVER_SOFTWARE");
  18. val cgi_server_name = Process.getEnv("SERVER_NAME");
  19. val cgi_gateway_interface = Process.getEnv("GATEWAY_INTERFACE");
  20. val cgi_server_protocol = Process.getEnv("SERVER_PROTOCOL");
  21. val cgi_server_port = Process.getEnv("SERVER_PORT");
  22. val cgi_request_method = Process.getEnv("REQUEST_METHOD");
  23. val cgi_http_accept = Process.getEnv("HTTP_ACCEPT");
  24. val cgi_http_user_agent = Process.getEnv("HTTP_USER_AGENT");
  25. val cgi_http_referer = Process.getEnv("HTTP_REFERER");
  26. val cgi_path_info = Process.getEnv("PATH_INFO");
  27. val cgi_path_translated = Process.getEnv("PATH_TRANSLATED");
  28. val cgi_script_name = Process.getEnv("SCRIPT_NAME");
  29. val cgi_query_string = Process.getEnv("QUERY_STRING");
  30. val cgi_remote_host = Process.getEnv("REMOTE_HOST");
  31. val cgi_remote_addr = Process.getEnv("REMOTE_ADDR");
  32. val cgi_remote_user = Process.getEnv("REMOTE_USER");
  33. val cgi_remote_ident = Process.getEnv("REMOTE_IDENT");
  34. val cgi_auth_type = Process.getEnv("AUTH_TYPE");
  35. val cgi_content_type = Process.getEnv("CONTENT_TYPE");
  36. val cgi_content_length = Process.getEnv("CONTENT_LENGTH");
  37. val cgi_annotation_server = Process.getEnv("ANNOTATION_SERVER");
  38.  
  39. local
  40.     open Option TextIO
  41.  
  42.     fun intOf NONE     = NONE
  43.       | intOf (SOME s) = Int.fromString s
  44.  
  45.     val query_string = 
  46.     case cgi_request_method of
  47.         SOME ("GET")  => getOpt(cgi_query_string,"")
  48.       | SOME ("POST") => inputN(stdIn, getOpt(intOf cgi_content_length, 0))
  49.       | _             => getOpt(cgi_query_string,"");     (* Perhaps GET *)
  50.  
  51.     fun isn't c1 c2 = c1 <> c2
  52.     fun is    c1 c2 = c1 = c2
  53.  
  54.     (* For debugging, one may log to the httpd error_log: *)
  55.  
  56.     fun err s = TextIO.output(TextIO.stdErr, s);
  57.  
  58.     (* val _ = err query_string;
  59.        val _ = err (Int.toString  (getOpt(intOf cgi_content_length, 0)));
  60.      *)
  61.  
  62.     (* Get the line starting with string s *)
  63.  
  64.     fun line s sus = 
  65.     let open Substring
  66.         val (_, fullline) = position s sus
  67.         val after = triml (String.size s) fullline
  68.     in takel (fn c => c <> #"\r" andalso c <> #"\n") after end
  69.  
  70.     (* Get the value of boundary *)
  71.  
  72.     fun getboundary line = 
  73.     let open Substring
  74.         val (_, bndeqn) = position "boundary=" line
  75.     in 
  76.         if isEmpty bndeqn then NONE
  77.         else SOME (string (triml 1 (dropl (isn't #"=") bndeqn)))
  78.     end
  79.         handle Option => NONE
  80.  
  81.     (* If CGI request type is multipart/form-data, then SOME(boundary):  *)
  82.  
  83.     val multipart_boundary = 
  84.     let open Substring
  85.         val content_type = all (valOf cgi_content_type)
  86.     in 
  87.         if isPrefix "multipart/form-data;" content_type then 
  88.         getboundary content_type
  89.         else
  90.         NONE
  91.     end
  92.         handle Option => NONE
  93.  
  94.     val the_fields =
  95.     case multipart_boundary of
  96.         NONE => Substring.tokens (is #"&") (Substring.all query_string)
  97.       | _    => []
  98.  
  99.     val dict_with_codes = List.map (Substring.fields (is #"=")) the_fields;
  100.  
  101.     (* Decode CGI parameters: *)
  102.  
  103.     fun decode(sus) =
  104.         let
  105.             val sz = Substring.size(sus);
  106.             exception Dehex;
  107.             fun dehex(ch) =
  108.                 if #"0" <= ch andalso ch <= #"9"
  109.                     then Char.ord(ch) - Char.ord(#"0")
  110.                 else if #"A" <= ch andalso ch <= #"F"
  111.                          then (Char.ord(ch) - Char.ord(#"A")) + 10
  112.                      else if #"a" <= ch andalso ch <= #"f"
  113.                               then (Char.ord(ch) - Char.ord(#"a")) + 10
  114.                           else raise Dehex;
  115.             fun decode_one(i) =
  116.                 Char.chr(16*dehex(Substring.sub(sus,i+1))+
  117.                  dehex(Substring.sub(sus,i+2)));
  118.             fun dec(i) =
  119.                 if i>=sz then []
  120.                 else case Substring.sub(sus,i)
  121.                        of #"+" => #" "::dec(i+1)
  122.                         | #"%" => decode_one(i)::dec(i+3)
  123.                         | ch => ch::dec(i+1);
  124.         in
  125.             String.implode(dec(0))
  126.         end handle exn => 
  127.         (err ("decode failed on " ^ Substring.string sus ^ "\n"); "")
  128.  
  129.     fun addItem ((key, value), dict) =
  130.     Splaymap.insert(dict, key, case Splaymap.peek(dict, key) of
  131.                             SOME vs => value :: vs 
  132.                       | NONE    => [value])
  133.  
  134.     fun addField ([keysrc, valsrc], dict) =
  135.     addItem ((decode keysrc, decode valsrc), dict)
  136.       | addField (_, dict) = dict
  137.  
  138.     val cgi_dict =
  139.         List.foldr addField (Splaymap.mkDict String.compare) dict_with_codes;
  140.  
  141.     fun keys dict = Splaymap.foldr (fn (key, _, res) => key :: res) [] dict
  142.  
  143.     (* Decode multipart messages: *)
  144.  
  145.     fun part_fields dict name = 
  146.     case Splaymap.peek (dict, name) of
  147.         NONE      => []
  148.       | SOME vals => vals
  149.  
  150.     fun part_field dict name =
  151.     case Splaymap.peek (dict, name) of
  152.         SOME (v :: _) => SOME v
  153.       | _             => NONE
  154.  
  155.     fun getint NONE       default = default
  156.       | getint (SOME str) default =
  157.     case Int.scan StringCvt.DEC Substring.getc (Substring.all str) of
  158.         NONE          => default
  159.       | SOME(i, rest) => if Substring.isEmpty rest then i else default
  160.  
  161.     val multiparts = 
  162.     let open Substring
  163.         val boundary = "--" ^ valOf multipart_boundary
  164.         val skipbnd = dropl (isn't #"\n") 
  165.         val (_, contents) = position boundary (all query_string)
  166.         fun loop rest =
  167.         let val (pref, suff) = position boundary rest
  168.         in 
  169.             if isEmpty pref orelse isEmpty suff then []
  170.             else pref :: loop (skipbnd suff)
  171.         end
  172.     in loop (skipbnd contents) end
  173.         handle Option => []
  174.  
  175.     fun decodepart (part : Substring.substring) = 
  176.     let open Char Substring
  177.         val crlf2 = "\r\n\r\n"
  178.         val (header, rest) = position crlf2 part
  179.         val eqnsrc = line "Content-Disposition: form-data;" header
  180.         val typ = line "Content-Type: " header
  181.         val equations = List.map (fn f => dropl isSpace (dropr isSpace f))
  182.                              (fields (is #";") eqnsrc)
  183.  
  184.         fun addField (eqn, dict) =
  185.         let val (name, v) = splitl (isn't #"=") eqn
  186.            (* Drop equals sign and quotes from value *)
  187.             val value = triml 2 (trimr 1 v)
  188.         in addItem((string name, string value), dict) end
  189.  
  190.         val dict = 
  191.         List.foldr addField (Splaymap.mkDict String.compare) equations
  192.  
  193.         val partname = 
  194.         case part_field dict "name" of
  195.             NONE   => "[Anonymous]" (* Is this is good idea? *)
  196.           | SOME n => n
  197.     in 
  198.         (partname, 
  199.          { fieldnames = keys dict,
  200.            tyOpt = if isEmpty typ then NONE else SOME (string typ),
  201.            dict  = dict, 
  202.            (* Strip off CRLFCRLF and CRLF *)
  203.            data  = string (trimr 2 (triml 4 rest))
  204.          })
  205.     end
  206.  
  207.     type part = {fieldnames : string list, 
  208.          tyOpt : string option, 
  209.          dict : (string, string list) Splaymap.dict,
  210.          data : string}
  211.     
  212.     val part_dict : (string, part list) Splaymap.dict =
  213.     List.foldr addItem (Splaymap.mkDict String.compare) 
  214.                   (List.map decodepart multiparts)
  215. in
  216.     type part = part
  217.     val cgi_partnames = keys part_dict
  218.     fun cgi_part  name = part_field  part_dict name
  219.     fun cgi_parts name = part_fields part_dict name
  220.  
  221.     fun part_fieldnames    (p : part) = #fieldnames p
  222.     fun part_type          (p : part) = #tyOpt p
  223.     fun part_data          (p : part) = #data p
  224.     fun part_field_strings (p : part) name = part_fields (#dict p) name
  225.     fun part_field_string  (p : part) name = part_field  (#dict p) name
  226.     fun part_field_integer (p : part) (name, default) = 
  227.     getint (part_field  (#dict p) name) default
  228.  
  229.     val cgi_fieldnames = keys cgi_dict
  230.     fun cgi_field_strings name = part_fields cgi_dict name
  231.     fun cgi_field_string name  = part_field cgi_dict name
  232.     fun cgi_field_integer (name, default) = 
  233.     getint (cgi_field_string name) default
  234. end;
  235.